(defun 0-pos (pos)
  (list (nth 0 pos)  
        (nth 1 pos)    
        (nth 2 pos)))

(defun 1-pos (pos)
  (list (+ 1 (nth 0 pos))
        (nth 1 pos)    
        (nth 2 pos)))

(defun 2-pos (pos)
  (list (nth 0 pos)  
        (nth 1 pos)    
        (+ 1 (nth 2 pos))))


(defun 3-pos (pos)
  (list (+ 1 (nth 0 pos))  
        (nth 1 pos)    
        (+ 1 (nth 2 pos))))

(defun 4-pos (pos)
  (list (nth 0 pos)  
        (+ 1 (nth 1 pos))
        (nth 2 pos)))

(defun 5-pos (pos)
  (list (+ 1 (nth 0 pos))  
        (+ 1 (nth 1 pos))    
        (nth 2 pos)))


(defun 6-pos (pos)
  (list (nth 0 pos)  
        (+ 1 (nth 1 pos))    
        (+ 1 (nth 2 pos))))

(defun 7-pos (pos)
  (list (+ 1 (nth 0 pos))  
        (+ 1 (nth 1 pos))    
        (+ 1 (nth 2 pos))))




(defun genera-tetrahedros (pos)
  (list
   (list (0-pos pos) (1-pos pos) (3-pos pos) (7-pos pos))
   (list (0-pos pos) (1-pos pos) (5-pos pos) (7-pos pos))
   (list (0-pos pos) (2-pos pos) (3-pos pos) (7-pos pos))
   (list (0-pos pos) (2-pos pos) (6-pos pos) (7-pos pos))
   (list (0-pos pos) (4-pos pos) (5-pos pos) (7-pos pos))
   (list (0-pos pos) (4-pos pos) (6-pos pos) (7-pos pos))
   ))


(defun genera-tetrahedros-lista (list)
  (if (endp list)
      nil
    (append (genera-tetrahedros (car list)) (genera-tetrahedros-lista (cdr list)))))


(defun coordinates-3d-to-facets (list)
  (if (endp list)
      nil
    (append (genera-tetrahedros (car list)) (coordinates-3d-to-facets (cdr list)))))




(defun 3D-to-facects (list)
  (transform-list-of-cons-pair (genera-tetrahedros-lista list))
  )



(defvar *hash* (make-hash-table :test 'equal))

(defvar *counter2* 0)

(defun transform-cons-to-nat (cons-pair)
  (cond ((endp cons-pair) nil)
        (t (let ((val (gethash (car cons-pair) *hash*)))
             (if val
                 (cons val (transform-cons-to-nat (cdr cons-pair)))
               (progn (setf (gethash (car cons-pair) *hash*) (1+ *counter2*))
                 (cons (incf *counter2*) (transform-cons-to-nat (cdr cons-pair)))))))))


(defun transform-cons-to-nat-aux (list)
  (cond ((endp list) nil)
        (t (cons (transform-cons-to-nat (car list)) 
                 (transform-cons-to-nat-aux (cdr list))))))


(defun add-pos (pos)
  (transform-cons-to-nat (list (6-pos pos) (2-pos pos) (3-pos pos) (7-pos pos)
                               (4-pos pos) (0-pos pos) (1-pos pos) (5-pos pos)  )  
                         ))

(defun add-pos2 (pos)
  (list (6-pos pos) (2-pos pos) (3-pos pos) (7-pos pos)
        (4-pos pos) (0-pos pos) (1-pos pos) (5-pos pos)))






(defun genera-tetrahedros-for-image (pos)
  (list
   (list (6-pos pos) (2-pos pos) (3-pos pos) (7-pos pos))
   (list (5-pos pos) (1-pos pos) (0-pos pos) (4-pos pos))
   (list (7-pos pos) (3-pos pos) (1-pos pos) (5-pos pos))
   (list (4-pos pos) (6-pos pos) (7-pos pos) (5-pos pos))
   (list (4-pos pos) (0-pos pos) (2-pos pos) (6-pos pos))
   (list (2-pos pos) (0-pos pos) (1-pos pos) (3-pos pos))
   ))


(defun all-vertices (list)
  (do ((temp list (cdr temp))
       (temp2 nil))
      ((endp temp) (progn (transform-cons-to-nat (remove-duplicates temp2 :test #'equal :from-end t))
                     (remove-duplicates temp2 :test #'equal :from-end t)))
    (setf temp2 (append temp2 (add-pos2 (car temp))))))

(defun genera-tetrahedros-for-image-list (list)
  (if (endp list)
      nil
    (append (genera-tetrahedros-for-image (car list)) (genera-tetrahedros-for-image-list (cdr list)))))

(defun print-list (list)
  (do ((temp list (cdr temp))
       (st ""))
      ((endp temp) st)
    (setf st (concatenate 'string st (format nil "~A " (car temp))))))

(defun print-vertices (list)
  (do ((temp list (cdr temp))
       (st ""))
      ((endp temp) st)
    (setf st (concatenate 'string st (format nil "v ~A~%" (print-list (car temp))))))  
  )

(defun print-tetrahedros (list)
  (do ((temp list (cdr temp))
       (st ""))
      ((endp temp) st)
    (setf st (concatenate 'string st (format nil "f ~A~%" (print-list (car temp))))))  
  )

(defun loc-to-obj (list)
  (let ((vertices nil)
        (tetrahedros nil)
        (st ""))
    (clrhash *hash*)
    (setf *counter2* 0)
    (setf vertices (all-vertices list))
    (setf tetrahedros (transform-cons-to-nat-aux (genera-tetrahedros-for-image-list list)))
    (setf st (concatenate 'string st (print-vertices vertices) (print-tetrahedros tetrahedros))) 
    st
    ))
  




(defun genera-facets-i-j-k (i j k)
  (genera-tetrahedros (list i j k))
  )


(defun genera-facets-line (list i j k)
  (if (endp list)
      nil
    (if (equal (car list) 1)
	(append (genera-facets-i-j-k i j k) 
		(genera-facets-line (cdr list) (1+ i) j k))
      (genera-facets-line (cdr list) (1+ i) j k)))
  )

(defun genera-facets-image-level (list j k)
  (if (endp list)
      nil
    (append (genera-facets-line (car list) 0 j k)
	    (genera-facets-image-level (cdr list) (1+ j) k))))


(defun genera-facets-image-3d-aux (list k)
  (if (endp list)
      nil
    (append (genera-facets-image-level (car list) 0 k)
	    (genera-facets-image-3d-aux (cdr list) (1+ k)))))

(defun generate-facets-image-3d (3da)
  (genera-facets-image-3d-aux 3da 0))






(defun 3da-to-obj (3da)
  (let ((coordinates nil))
    (do ((temp 3da (cdr temp))
         (k 0 (1+ k)))
        ((endp temp) coordinates)
      (do ((temp2 (car temp) (cdr temp2))
           (j 0 (1+ j)))
          ((endp temp2) nil)
        (do ((temp3 (car temp2) (cdr temp3))
             (i 0 (1+ i)))
            ((endp temp3) nil)
          (if (equal (car temp3) 1)
              (setf coordinates (append coordinates (list (list i j k))))))))
    (loc-to-obj coordinates)))
  
  
  
  


#|

(setf cubo 
  (genera-tetrahedros-lista '((0 0 0) (1 0 0) (2 0 0) (0 1 0) (1 1 0) (2 1 0) (0 2 0) (1 2 0) (2 2 0)
                              (0 0 1) (1 0 1) (2 0 1) (0 1 1) (1 1 1) (2 1 1) (0 2 1) (1 2 1) (2 2 1)
                              (0 0 2) (1 0 2) (2 0 2) (0 1 2) (1 1 2) (2 1 2) (0 2 2) (1 2 2) (2 2 2)
                              )))

(setf sc-cubo (simplicial-complex-generator (transform-list-of-cons-pair cubo)))

(setf ss-sc-cubo (ss-from-sc sc-cubo))
  
(homology ss-sc-cubo 0)  
(homology ss-sc-cubo 1)
(homology ss-sc-cubo 2)



(setf toro-macizo 
  (genera-tetrahedros-lista '((0 0 0) (1 0 0) (2 0 0) (0 1 0) (1 1 0) (2 1 0) (0 2 0) (1 2 0) (2 2 0)
                              (0 0 1) (1 0 1) (2 0 1) (0 1 1) (2 1 1) (0 2 1) (1 2 1) (2 2 1)
                              (0 0 2) (1 0 2) (2 0 2) (0 1 2) (1 1 2) (2 1 2) (0 2 2) (1 2 2) (2 2 2)
                              )))

(setf sc-toro-macizo (simplicial-complex-generator (transform-list-of-cons-pair toro-macizo)))

(setf ss-sc-toro-macizo (ss-from-sc sc-toro-macizo))
  
(homology ss-sc-toro-macizo 0)  
(homology ss-sc-toro-macizo 1)
(homology ss-sc-toro-macizo 2)



; cubo con tres tuneles

(setf cubo-3-tuneles
  (genera-tetrahedros-lista '((0 0 0) (1 0 0) (2 0 0) (0 1 0) (1 1 0) (2 1 0) (0 2 0) (1 2 0) (2 2 0)
                              (0 0 1) (2 0 1) (0 2 1) (2 2 1)
                              (0 0 2) (1 0 2) (2 0 2) (0 1 2) (1 1 2) (2 1 2) (0 2 2) (1 2 2) (2 2 2)
                              )))

(setf sc-cubo-3-tuneles (simplicial-complex-generator (transform-list-of-cons-pair cubo-3-tuneles)))

(setf ss-sc-cubo-3-tuneles (ss-from-sc sc-cubo-3-tuneles))
  
(homology ss-sc-cubo-3-tuneles 0)  
(homology ss-sc-cubo-3-tuneles 1)
(homology ss-sc-cubo-3-tuneles 2)


; cubo con cinco tuneles

(setf cubo-5-tuneles
  (genera-tetrahedros-lista '((0 0 0) (1 0 0) (2 0 0) (0 1 0) (2 1 0) (0 2 0) (1 2 0) (2 2 0)
                              (0 0 1) (2 0 1) (0 2 1) (2 2 1)
                              (0 0 2) (1 0 2) (2 0 2) (0 1 2) (2 1 2) (0 2 2) (1 2 2) (2 2 2)
                              )))

(setf sc-cubo-5-tuneles (generate-from-maximales (transform-list-of-cons-pair cubo-5-tuneles)))

(setf ss-sc-cubo-5-tuneles (ss-from-sc sc-cubo-5-tuneles))
  
(homology ss-sc-cubo-5-tuneles 0)  
(homology ss-sc-cubo-5-tuneles 1)
(homology ss-sc-cubo-5-tuneles 2)




(setf cubo-hueco-con-tunel 
  (genera-tetrahedros-lista '((0 0 0) (1 0 0) (2 0 0) (3 0 0) (4 0 0) (5 0 0) (6 0 0)
                              (0 1 0) (1 1 0) (2 1 0) (3 1 0) (4 1 0) (5 1 0) (6 1 0)
                              (0 2 0) (1 2 0) (2 2 0) (3 2 0) (4 2 0) (5 2 0) (6 2 0)
                              (0 3 0) (1 3 0) (2 3 0)         (4 3 0) (5 3 0) (6 3 0)
                              (0 4 0) (1 4 0) (5 4 0) (2 4 0) (3 4 0) (4 4 0) (6 4 0)
                              (0 5 0) (1 5 0) (2 5 0) (3 5 0) (4 5 0) (5 5 0) (6 5 0)
                              (0 6 0) (1 6 0) (2 6 0) (3 6 0) (4 6 0) (5 6 0) (6 6 0)
                              
                              (0 0 1) (1 0 1) (2 0 1) (3 0 1) (4 0 1) (5 0 1) (6 0 1)
                              (0 1 1)                                         (6 1 1)
                              (0 2 1)         (2 2 1) (3 2 1) (4 2 1)         (6 2 1)
                              (0 3 1)         (2 3 1)         (4 3 1)         (6 3 1)
                              (0 4 1)         (2 4 1) (3 4 1) (4 4 1)         (6 4 1)
                              (0 5 1)                                         (6 5 1)
                              (0 6 1) (1 6 1) (2 6 1) (3 6 1) (4 6 1) (5 6 1) (6 6 1)
                                                           
                              (0 0 2) (1 0 2) (2 0 2) (3 0 2) (4 0 2) (5 0 2) (6 0 2)
                              (0 1 2) (1 1 2) (2 1 2) (3 1 2) (4 1 2) (5 1 2) (6 1 2)
                              (0 2 2) (1 2 2) (2 2 2) (3 2 2) (4 2 2) (5 2 2) (6 2 2)
                              (0 3 2) (1 3 2) (2 3 2)         (4 3 2) (5 3 2) (6 3 2)
                              (0 4 2) (1 4 2) (2 4 2) (3 4 2) (4 4 2) (5 4 2) (6 4 2)
                              (0 5 2) (1 5 2) (2 5 2) (3 5 2) (4 5 2) (5 5 2) (6 5 2)
                              (0 6 2) (1 6 2) (2 6 2) (3 6 2) (4 6 2) (5 6 2) (6 6 2)                                
                              )))

(setf sc-cubo-hueco-tunel (generate-from-maximales (transform-list-of-cons-pair cubo-hueco-con-tunel)))

(setf ss-sc-cubo-tunel (ss-from-sc sc-cubo-hueco-tunel))
  
(homology ss-sc-cubo-tunel 0)  
(homology ss-sc-cubo-tunel 1)
(homology ss-sc-cubo-tunel 2)

  
|#





